# Definition and implementation of the Story class.

itcl::class Story {

	# DSC comments have a limitation of 255 characters per line, we'll target a smaller width.
	common eTargetLineWidth 80

	proc toString {word}
	proc fromString {tokens remainder}
	proc toName {word}
	proc fromName {tokens remainder}
	proc toText {word}
	proc fromText {tokens remainder}
	proc toTextList {wordList}
	proc fromTextList {tokens remainder}
	proc toChar {word}
	proc ofChar {token}
	proc fromChar {tokens remainder}
	proc toBoolean {word}
	proc ofBoolean {token}
	proc fromBoolean {tokens remainder}
	proc toValue {word}
	proc fromValue {tokens remainder}
	proc toDict {wordList}

	proc tokenize {tokens remainder}
	proc parseAttributes {tokens}
	proc simplify {tokens stackPtr token}

	proc toKey {word} {
		join [lapply $word "string totitle"] ""
	}
	proc fromKey {key} {
		string tolower [string trim [regsub "(\[A-Z\])" $key " \\1"]]
	}
	proc listKeys {keys {last and}} {
		switch [llength $keys] 0 {
			return {}
		} 1 {
			return [fromKey $keys]
		} default {
			return "[join [lapply [lrange $keys 0 end-1] fromKey] ", "] $last [fromKey [lindex $keys end]]" 
		}
	}

	proc toHex {c} {scan $c "%c" x; format "\\u%04x" $x}
	proc hexify {word} {
		set hexified ""
		for {set idx 0} {$idx < [string length $word]} {incr idx} {
			set char [string index $word $idx]
			if {[regexp "\\\w" $char] && [regexp "\[^a-zA-Z0-9\]" $char]} {
				append hexified [toHex $char]
			} else {
				append hexified $char
			} 
		}
		return $hexified
	}

	common cAbsoluteRoundingError .001
	common cPi [expr 4 * atan(1)]

	proc undouble {double} {if {[isEqual [expr round($double)] $double]} {expr round($double)} {regsub "0+$" [regsub "^(-?)0+" $double "\\1"] ""}}
	proc dedouble {double {precision 2}} {undouble [format "%.${precision}f" $double]}
	proc roundDown {dividend divisor} {expr int(floor($dividend / double($divisor) + $cAbsoluteRoundingError))}
	proc roundUp {dividend divisor} {expr int(ceil($dividend / double($divisor) - $cAbsoluteRoundingError))}
	proc isEqual {double1 double2} {expr abs($double1 - $double2) <= $cAbsoluteRoundingError}
	proc isSmaller {double1 double2} {expr $double1 + $cAbsoluteRoundingError <= $double2}
	proc isGreater {double1 double2} {expr $double1 - $cAbsoluteRoundingError >= $double2}
	proc isSmallerOrEqual {double1 double2} {expr $double1 - $cAbsoluteRoundingError <= $double2}
	proc isGreaterOrEqual {double1 double2} {expr $double1 + $cAbsoluteRoundingError >= $double2}
	
	proc toRad {a} {expr $a * $cPi / 180.}
	proc toDeg {a} {expr $a * 180. / $cPi}

	proc distance {pt1 pt2} {foreach {x1 y1} $pt1 {x2 y2} $pt2 {return [expr sqrt(($x2 - $x1) * ($x2 - $x1) + ($y2 - $y1) * ($y2 - $y1))]}}
	proc angleInDegrees {ptm pt} {foreach {x y} $pt {xm ym} $ptm {return [expr atan2($y - $ym, $x - $xm) * 45. / atan(1.)]}}
	
	proc chooseBetween {candidates} {join [regsub -all {[^\w\s]} $candidates {\\&}] "|"}

	protected proc scanParentheses {words}
	protected proc scanCurlyBrackets {tokens}
	
	constructor {fileSpec tributes} {
		set iFileId [::open $fileSpec w]
		
		set iAttributes [iarray::Array #auto $tributes]

		set iIndentation [$iAttributes on indentation $iIndentation]
		set iStructured [$iAttributes on structured $iStructured]
		set iComposed [$iAttributes on composed $iComposed]

		set encoding [$iAttributes on encoding ""]
		if {[string length $encoding]} {
			fconfigure $iFileId -encoding $encoding
		}
		set translation [$iAttributes on translation "lf"]
		if {[string length $translation]} {
			fconfigure $iFileId -translation $translation
		}
	}	
	destructor {
		::close $iFileId
		assert {$iIndentLevel == 0} {
			Indentation $iIndentLevel when closing file.
		}

		itcl::delete object $iAttributes
	}

	method getAttribute {name default} {
		$iAttributes on $name $default
	}
	
	method write {type args} {
		switch $type gap {
			assert {[llength $args] == 0} {
				Writing a gap requires no arguments.
			}
			puts $iFileId ""
		} line {
			assert {[llength $args] == 1} {
				Writing a line requires 1 argument.
			}
			set line [lindex $args 0]
			if {![string length $line]} {
				write gap
			} elseif {$iComposed || [string match "% *" $line] || !([string match "%? *" $line] || [string match "%?? *" $line])} {
				for {set i 0} {$i < $iIndentLevel} {incr i} {puts -nonewline $iFileId $iIndentation}
				puts $iFileId $line
			}
		} part {
			assert {([llength $args] == 2) || ([llength $args] == 3)} {
				Writing a part requires 2 or 3 arguments.
			}
			if {[llength $args] == 2} {
				set tributes {}
			} else {
				set tributes [lindex $args 2]
			}
			set part [lindex $args 0]
			set class [string range [$part info class] 2 end]

			if {!$iComposed} {
				if {$iStructured} {
					foreach {key values} [$part getResources] {
						foreach value $values {
							write comment IncludeResource "$key [toText $value]"
						}
					}
				}
				$part autoWrite $this $tributes
				return
			}

			set attributes [toText [lindex $args 1]]
			set allowed [expr $eTargetLineWidth - [string length  "%<$class $attributes>"]]
			set remainder {}
			set tokens ""
			foreach {attribute value} [$part getAttributes] {
				if {$allowed < 0} {
					lappend remainder $attribute $value
				} else {
					set attributed [toName $attribute]
					set valued [toValue $value]
					set valuedLength [string length $valued]
					incr allowed [expr -2 - [string length $attributed] - $valuedLength]
					if {$allowed >= 0} {
						append attributes " $attributed $valued"
					} elseif {$allowed + 1 + $valuedLength >= 0} {
						append attributes " $attributed"
						incr allowed [expr 1 + $valuedLength]
						if {($allowed >= 2) && [string equal -length 1 $valued "\{"]} { 
							set token "\{"
							set tokens [string range $valued 1 end]
							incr allowed -2
							while {$allowed >= 0} {
								append attributes " $token"
								if {![string length $tokens]} {
									set token ""
									break
								}
								set token [tokenize $tokens tokens]
								incr allowed [expr -1 - [string length $token]]
							}
							set tokens "$token$tokens"
						} else {
							set allowed -1
							set tokens $valued
						}
					} else {
						set remainder [list $attribute $value]
					}
				}
			}

			if {($allowed >= 2) && [$part isEmpty] && ![llength [$part getResources]]} {
				puts $iFileId "%<$class $attributes/>"
			} else {
				puts $iFileId "%<$class $attributes>"
				if [string length $tokens] {
					write addition $tokens $remainder
				} elseif {[string length $remainder]} {
					write addition $remainder
				}
				if $iStructured {
					foreach {key values} [$part getResources] {
						foreach value $values {
							write comment IncludeResource "$key [toText $value]"
						}
					}
				}
				$part autoWrite $this $tributes
				puts $iFileId "%</$class>"
			}
		} addition {
			assert {([llength $args] == 1) || ([llength $args] == 2)} {
				Writing an addition comment requires 1 or 2 arguments.
			}

			if {[llength $args] == 2} {
				set tokens [lindex $args 0]
				set all [lindex $args 1]
				set attributes [tokenize $tokens tokens]
				set allowed [expr $eTargetLineWidth - [string length  "%<+ $attributes>"]]
				while {[string length $tokens]} {
					set token [tokenize $tokens tokens]
					incr allowed [expr -1 - [string length $token]]
					if {$allowed < 0} {
						puts $iFileId "%<+ $attributes>"
						write addition "$token$tokens" $all
						return
					}
					append attributes " $token"
				}
			} else {
				set all [lindex $args 0]
				set attributes [toName [lindex $all 0]]
				set valued [toValue [lindex $all 1]]
				set all [lrange $all 2 end]
				set valuedLength [string length $valued] 
				set allowed [expr $eTargetLineWidth - [string length  "%<+ $attributes>"]]
				if {$allowed < $valuedLength + 1} {
					if {($allowed >= 2) && [string equal -length 1 $valued "\{"]} { 
						set token "\{"
						set tokens [string range $valued 1 end]
						incr allowed -2
						while {$allowed >= 0} {
							append attributes " $token"
							if {![string length $tokens]} {
								puts $iFileId "%<+ $attributes>"
								write addition $all
								return
							}
							set token [tokenize $tokens tokens]
							incr allowed [expr -1 - [string length $token]]
						}
						set tokens "$token$tokens"
					} else {
						set tokens $valued
					}
					puts $iFileId "%<+ $attributes>"
					write addition $tokens $all
					return
				}
				append attributes " $valued"
				incr allowed [expr -1 - $valuedLength]
			}

			set remainder {}
			set tokens ""
			foreach {attribute value} $all {
				if {$allowed < 0} {
					lappend remainder $attribute $value
				} else {
					set attributed [toName $attribute]
					set valued [toValue $value]
					set valuedLength [string length $valued]
					incr allowed [expr -2 - [string length $attributed] - $valuedLength]
					if {$allowed >= 0} {
						append attributes " $attributed $valued"
					} elseif {$allowed + 1 + $valuedLength >= 0} {
						append attributes " $attributed"
						incr allowed [expr 1 + $valuedLength]
						if {($allowed >= 2) && [string equal -length 1 $valued "\{"]} { 
							set token "\{"
							set tokens [string range $valued 1 end]
							incr allowed -2
							while {$allowed >= 0} {
								append attributes " $token"
								if {![string length $tokens]} {
									set token ""
									break
								}
								set token [tokenize $tokens tokens]
								incr allowed [expr -1 - [string length $token]]
							}
							set tokens "$token$tokens"
						} else {
							set allowed -1
							set tokens $valued
						}
					} else {
						set remainder [list $attribute $value]
					}
				}
			}

			puts $iFileId "%<+ $attributes>"
			if [string length $tokens] {
				write addition $tokens $remainder
			} elseif {[string length $remainder]} {
				write addition $remainder
			}
		} sequence {
			assert {([llength $args] == 1) || ([llength $args] == 2)} {
				Writing a sequence requires 1 or 2 arguments.
			}
			if {[llength $args] == 1} {
				set tributes {}
			} else {
				set tributes [lindex $args 1]
			}
			if $iComposed {write gap}
			foreach {name part} [[lindex $args 0] get] {
				write part $part $name $tributes
				if $iComposed {write gap}
			}
		} comment {
			assert {([llength $args] == 1) || ([llength $args] == 2)} {
				Writing a DSC comment requires 1 or 2 arguments.
			}
			if {[llength $args] == 1} {
				puts $iFileId "%%[lindex $args 0]"
			} else {
				puts $iFileId "%%[lindex $args 0]: [lindex $args 1]"
			}
		} continuation {
			assert {[llength $args] == 1} {
				Writing a continuation comment requires 1 argument.
			}
			puts $iFileId "%%+ [lindex $args 0]"
		} resources {
			if {!$iStructured} return

			assert {([llength $args] == 1) || ([llength $args] == 2)} {
				Writing a resources comment requires 1 or 2 arguments.
			}
			if {[llength $args] == 2} {
				set lead "[lindex $args 0]:"
				set resources [lindex $args 1]
			} else {
				set lead "+"
				set resources [lindex $args 0]
			}
			set key [lindex $resources 0]
			set values [lindex $resources 1]
			set resource "$key [toText [lindex $values 0]]"
			set remainder ""
			set allowed [expr $eTargetLineWidth - [string length  "%%$lead $resource"]]
			foreach value [lrange $values 1 end] {
				if {$allowed < 0} {
					lappend remainder $value
				} else {
					set valued [toText $value]
					incr allowed [expr -1 - [string length $valued]]
					if {$allowed >= 0} {
						append resource " $valued"
					} else {
						set remainder $value
					}
				} 
			}
			write line "%%$lead $resource"
			if {$allowed < 0} {
				write resources [list $key $remainder]
			}
			if {[llength $resources] > 2} {
				write resources [lrange $resources 2 end]
			}
		} version {
			assert {[llength $args] == 1} {
				Writing a version comment requires 1 argument.
			}
			puts $iFileId "%![lindex $args 0]"
		} default {
			assert 0 {
				Not able to interpret <$type> to write in story.
			}
		}
	}
	method indent {} {
		incr iIndentLevel
	}
	method deindent {} {
		assert {$iIndentLevel > 0} {
			Deindenting beyond 0.
		}
		incr iIndentLevel -1
	}

	variable iFileId {}
	variable iAttributes
	variable iIndentLevel 0
	variable iIndentation "\t"
	variable iStructured 1
	variable iComposed 1
}

itcl::body Story::tokenize {tokens remainder} {
	upvar $remainder remain
	set tokens [string trimleft $tokens]
	if {[string length $tokens] == 0} {
		set remain ""
		return ""
	}
	if {![regexp -indices "<<|>>|\[\]\[()<>{}/% \t\n\r\]" $tokens indices]} {
		set remain ""
		return $tokens
	}
	set reserved [eval [list string range $tokens] $indices]
	assert {[string first $reserved ")>"] == -1} {
		Matching opening bracket not found in <$tokens>.
	}
	set idx [lindex $indices 0]
	if {$idx > 0} {
		set remain [string range $tokens $idx end]
		return [string range $tokens 0 [expr $idx - 1]]
	}
	switch -- $reserved "(" {
		set close [scanParentheses [string range $tokens 1 end]]
		assert {$close != -1} {
			Matching closing bracket not found in <$tokens>.
		}
		incr close
		assert {[string equal ")" [string index $tokens $close]]} {
			Matching closing bracket not found in <$tokens>.
		}
		set remain [string range $tokens [expr $close + 1] end]
		return [string range $tokens 0 $close]
	} "/" {
		if {![regexp -indices "\[\]\[()<>{}/% \t\n\r\]" [string range $tokens 1 end] indices]} {
			set remain ""
			return $tokens
		} else {
			set idx [lindex $indices 0]
			set remain [string range $tokens [expr $idx + 1] end]
			return [string range $tokens 0 $idx]
		} 
	} "<" {
		set close [string first ">" $tokens]
		assert {$close != -1} {
			Matching closing bracket not found in <$tokens>.
		}
		set remain [string range $tokens [expr $close + 1] end]
		if {$close == 2} {return [toChar [string index $tokens 1]]}
		return [string range $tokens 0 $close]
	} "%" {
		if {![regexp -indices "\[\n\r\]" [string range $tokens 1 end] indices]} {
			set remain ""
			return $tokens
		} else {
			set idx [lindex $indices 0]
			set remain [string range $tokens [expr $idx + 2] end]
			return [string range $tokens 0 $idx]
		} 		
	} "\{" {
		set close [scanCurlyBrackets [string range $tokens 1 end]]
		if {$close != -1} {
			incr close
			if {[string equal "\}" [string index $tokens $close]]} {
				set remain [string range $tokens [expr $close + 1] end]
				if {[regexp "^#\[1-9\]?" $remain precision]} {
					set extra [string length $precision]
					incr close $extra
					set remain [string range $remain $extra end]
					return [string range $tokens 0 $close] 
				}
			}
		}
	} 
	set remain [string range $tokens [string length $reserved] end]
	return $reserved
}

# Simplify expressions that contain variables which have been replaced by their actual values.
# Acts as a partial PostScript interpreter for some simple, mostly mathematical, operators.
itcl::body Story::simplify {tokens stackPtr token} {
	upvar $stackPtr stack
	set stacked $stack
	set stack {}
	if {![string length $token]} {
		return [concat $tokens $stacked]
	}
	if [string is double $token] {
		set stack [concat $stacked $token]
		return $tokens
	}
	if {![llength $stacked]} {
		return [concat $tokens $token]
	}
	if {![string is lower $token]} {
		return [concat $tokens $stacked $token]
	}

	switch -- $token neg {
		set stack [lreplace $stacked end end [expr -[lindex $stacked end]]]
		return $tokens
	} sqrt {
		set stack [lreplace $stacked end end [expr sqrt([lindex $stacked end])]]
		return $tokens
	} round {
		set stack [lreplace $stacked end end [expr round([lindex $stacked end])]]
		return $tokens
	} dup {
		set stack [concat $stacked [lindex $stacked end]]
		return $tokens
	} pop {
		set stack [lrange $stacked 0 end-1]
		return $tokens
	} add {
		if {[lindex $stacked end] == 0} {
			set stack [lrange $stacked 0 end-1]
			return $tokens
		}
	} sub {
		if {[lindex $stacked end] == 0} {
			set stack [lrange $stacked 0 end-1]
			return $tokens
		}
	} mul {
		if {[lindex $stacked end] == 1} {
			set stack [lrange $stacked 0 end-1]
			return $tokens
		}
	} div {
		if {[lindex $stacked end] == 1} {
			set stack [lrange $stacked 0 end-1]
			return $tokens
		}
	} idiv {
		if {[lindex $stacked end] == 1} {
			set stack [lrange $stacked 0 end-1]
			return $tokens
		}
	} scalefont {
		if {[lindex $stacked end] == 1} {
			set stack [lrange $stacked 0 end-1]
			return $tokens
		}
	}

	if {[llength $stacked] < 2} {
		return [concat $tokens $stacked $token]
	}

	switch -- $token add {
		set stack [lreplace $stacked end-1 end [expr [lindex $stacked end-1] + [lindex $stacked end]]]
		return $tokens
	} sub {
		set stack [lreplace $stacked end-1 end [expr [lindex $stacked end-1] - [lindex $stacked end]]]
		return $tokens
	} mul {
		set stack [lreplace $stacked end-1 end [undouble [expr [lindex $stacked end-1] * [lindex $stacked end]]]]
		return $tokens
	} div {
		set stack [lreplace $stacked end-1 end [undouble [expr [lindex $stacked end-1] / double([lindex $stacked end])]]]
		return $tokens			
	} idiv {
		set stack [lreplace $stacked end-1 end [expr [lindex $stacked end-1] / [lindex $stacked end]]]
		return $tokens
	} mod {
		set stack [lreplace $stacked end-1 end [expr [lindex $stacked end-1] % [lindex $stacked end]]]
		return $tokens
	} min {
		if {[lindex $stacked end-1] <= [lindex $stacked end]} {
			set stack [lreplace $stacked end end]
		} else {
			set stack [lreplace $stacked end-1 end [lindex $stacked end]]
		}
		return $tokens
	} max {
		if {[lindex $stacked end-1] >= [lindex $stacked end]} {
			set stack [lreplace $stacked end end]
		} else {
			set stack [lreplace $stacked end-1 end [lindex $stacked end]]
		}
		return $tokens
	} exch {
		set stack [lreplace $stacked end-1 end [lindex $stacked end] [lindex $stacked end-1]]
		return $tokens
	} translate {
		if {([lindex $stacked end-1] == 0) && ([lindex $stacked end] == 0)} {
			set stack [lrange $stacked 0 end-2]
			return $tokens
		}
	} scale {
		if {([lindex $stacked end-1] == 1) && ([lindex $stacked end] == 1)} {
			set stack [lrange $stacked 0 end-2]
			return $tokens
		}
	}

	return [concat $tokens $stacked $token]
}

# Scan for the first unmatched parenthesis. A parenthesis preceded by an odd number of backslashes is not counted.
itcl::body Story::scanParentheses {words} {
	set opened 0
	set scanned 0
	while {[regexp -indices "(^|\[^\\\\\])(\\\\\\\\)*\[()\]" $words indices]} {
		set idx [lindex $indices 1]
		switch -- [string index $words $idx] "(" {
			incr opened
			if {$opened == 1} {set firstOpen [expr $scanned + $idx]}
		} ")" {
			if {$opened == 0} {return [expr $scanned + $idx]}
			incr opened -1
		}
		incr scanned [expr $idx + 1]
		set words [string range $words [expr $idx + 1] end]
	}
	if {$opened >= 1} {return $firstOpen}
	return -1
}

# Scan for the first unmatched token curly bracket. Curly brackets within strings don't count.
itcl::body Story::scanCurlyBrackets {tokens} {
	set opened 0
	set length [string length $tokens]
	while {[string length [set token [tokenize $tokens tokens]]]} {
		switch -- $token "\{" {
			incr opened
			if {$opened == 1} {set firstOpen [expr $length - [string length $tokens] - 1]}
		} "\}" {
			if {$opened == 0} {return [expr $length - [string length $tokens] - 1]}
			incr opened -1
		}
	}
	if {$opened >= 1} {return $firstOpen}
	return -1
}

itcl::body Story::toString {word} {
	regsub -all "\\\\" $word "\\\\\\\\" word
	set balanced $word
	set word ""
	while {[set idx [scanParentheses $balanced]] != -1} {
		append word [string range $balanced 0 [expr $idx - 1]] "\\" [string index $balanced $idx]
		set balanced [string range $balanced [expr $idx + 1] end]
	}
	append word $balanced 
	return "($word)"
}

itcl::body Story::fromString {tokens remainder} {
	set tokens [string trimleft $tokens]
	upvar $remainder remain
	assert [string equal -length 1 $tokens "("] {
		String <$tokens> doesn't start with an opening bracket.
	} 
	set idx [scanParentheses [string range $tokens 1 end]]
	assert {($idx != -1) && ([string equal [string index $tokens [expr $idx + 1]] ")"])} {
		String <$tokens> doesn't contain a matching closing bracket.
	}
	set remain [string range $tokens [expr $idx + 2] end]
	# Resolve backslashes. Tcl and PostScript give nearly the same meaning to special characters.
	eval concat [string range $tokens 1 $idx]
}

itcl::body Story::toName {word} {
	if {[regexp "\[\]\[()<>{}/% \t\n\r\]" $word special]} {
		assert 0 {
			Name <$word> contains a reserved character <$special>.
		}
	}
	return "/$word"
}

itcl::body Story::fromName {tokens remainder} {
	set tokens [string trimleft $tokens]
	upvar $remainder remain
	assert [string equal -length 1 $tokens "/"] {
		Name <$tokens> doesn't start with a slash.
	}
	if {![regexp -indices "\[\]\[()<>{}/% \t\n\r\]" [string range $tokens 1 end] indices]} {
		set remain ""
		return [string range $tokens 1 end]
	} else {
		set idx [lindex $indices 0]
		set remain [string range $tokens [expr $idx + 1] end]
		return [string range $tokens 1 $idx]
	} 
}

itcl::body Story::toText {word} {
	if {![string length $word]} {return "()"}
	if {[regexp "\[\]\[()<>{}/% \t\n\r\]" $word special]} {
		return [toString $word]
	}
	return $word
}

itcl::body Story::fromText {tokens remainder} {
	set tokens [string trimleft $tokens]
	upvar $remainder remain
	if {![string length $tokens]} {
		set remain ""
		return ""
	}
	if [string equal -length 1 $tokens "("] {
		return [fromString $tokens remain]
	}
	if {[regexp "^<(.)>" $tokens dummy char] && ![string equal -length 4 $tokens "<<>>"]} {
		set remain [lrange $tokens 3 end]
		return [toChar $char]
	}
	if {![regexp -indices "\[\]\[()<>{}/% \t\n\r\]" $tokens indices]} {
		set remain ""
		return $tokens
	} else {
		set idx [lindex $indices 0]
		assert $idx {
			Text <$tokens> starts with the special character <[string index $tokens 0]>.
		}
		set remain [string range $tokens $idx end]
		return [string range $tokens 0 [expr $idx - 1]]
	} 
}

itcl::body Story::toTextList {wordList} {
	if {![llength $wordList]} {return "{}"}

	set textList [Story::toText [lindex $wordList 0]]
	if {[llength $wordList] == 1} {return $textList}

	foreach name [lrange $wordList 1 end] {
		append textList " [Story::toText $name]"
	}
	return "{$textList}"
}

itcl::body Story::fromTextList {tokens remainder} {
	upvar $remainder remain

	set textList [Story::fromValue $tokens remain]
	set wordList {}
	while {[string length $textList]} {
		lappend wordList [Story::fromText $textList textList]
	}
	return $wordList
}

itcl::body Story::toChar {word} {
	scan $word "%c"
}

itcl::body Story::ofChar {token} {
	assert {[string is integer -strict $token] && ($token >= 0) && ($token < 256)} {
		Illegal character: <$token> is not the index of a valid ASCII character.
	}
	# Decimal to octal, then eval.
	eval list "\\[expr ($token % 8) + (($token / 8) % 8) * 10 + (($token / 64) % 8) * 100]" 
}

itcl::body Story::fromChar {tokens remainder} {
	set tokens [string trimleft $tokens]
	upvar $remainder remain
	if {![regexp -indices "\[\]\[()<>{}/% \t\n\r\]" $tokens indices]} {
		set token $tokens
		set remain ""
	} else {
		set idx [lindex $indices 0]
		set remain [string range $tokens $idx end]
		set token [string range $tokens 0 [expr $idx - 1]]
	}
	ofChar $token
}

itcl::body Story::toBoolean {word} {
	if $word {return "true"} else {return "false"}
}

itcl::body Story::ofBoolean {token} {
	assert {[string equal $token "true"] || [string equal $token "false"]} {
		Illegal boolean: <$token> is neither <true> nor <false>.
	}
	string equal $token "true"
}

itcl::body Story::fromBoolean {tokens remainder} {
	set tokens [string trimleft $tokens]
	upvar $remainder remain
	if {![regexp -indices "\[\]\[()<>{}/% \t\n\r\]" $tokens indices]} {
		set token $tokens
		set remain ""
	} else {
		set idx [lindex $indices 0]
		set remain [string range $tokens $idx end]
		set token [string range $tokens 0 [expr $idx - 1]]
	}
	ofBoolean $token
}

itcl::body Story::toValue {word} {
	set tokens [string trim $word]
	if {![string length $tokens]} {return "{}"}
	assert {[scanCurlyBrackets $tokens] == -1} {
		Illegal value: <$tokens> contains an unmatched curly bracket.
	}
	tokenize $tokens remain
	if {![string length $remain]} {
		if {[string is double $tokens]} {
			return [dedouble $tokens 8]
		} else {
			return $tokens
		}
	}
	return "{$tokens}"
}

itcl::body Story::fromValue {tokens remainder} {
	set tokens [string trimleft $tokens]
	upvar $remainder remain
	if {![string equal -length 1 $tokens "\{"]} {return [tokenize $tokens remain]}
	set bracket [expr [scanCurlyBrackets [string range $tokens 1 end]] + 1]
	assert {($bracket != 0) && ![string equal [string index $tokens $bracket] "\{"]} {
		Unmatched opening bracket in value <$tokens>.
	}
	set remain [string range $tokens [expr $bracket + 1] end]
	return [string trim [string range $tokens 1 [expr $bracket - 1]]]
}

itcl::body Story::toDict {wordList} {
	set tokens "currentdict end"
	foreach word $wordList {
		set tokens "[Story::toName $word] xd $tokens"
	}
	return "[llength $wordList] dict begin $tokens"
}
